home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / smaltalk.lha / smalltalk-1.1.1 / st.el < prev    next >
Lisp/Scheme  |  1991-09-12  |  30KB  |  987 lines
  1. ;;;
  2. ;;; Smalltalk mode for Gnu Emacs
  3. ;;;
  4.  
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6. ;;;
  7. ;;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  8. ;;; Written by Steve Byrne.
  9. ;;; 
  10. ;;; This file is part of GNU Smalltalk.
  11. ;;;  
  12. ;;; GNU Smalltalk is free software; you can redistribute it and/or modify it
  13. ;;; under the terms of the GNU General Public License as published by the Free
  14. ;;; Software Foundation; either version 1, or (at your option) any later 
  15. ;;; version.
  16. ;;;
  17. ;;; GNU Smalltalk is distributed in the hope that it will be useful, but
  18. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19. ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  20. ;;; for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License along
  23. ;;; with GNU Smalltalk; see the file COPYING.  If not, write to the Free
  24. ;;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25. ;;;
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28. (require 'shell)
  29.  
  30. (defvar smalltalk-name-regexp "[A-Za-z][A-Za-z0-9]*"
  31.   "A regular expression that matches a Smalltalk identifier")
  32.  
  33. (defvar smalltalk-name-chars "a-zA-Z0-9"
  34.   "The collection of character that can compose a Smalltalk identifier")
  35.  
  36. (defvar smalltalk-whitespace " \t\n\f")
  37.  
  38. (defvar smalltalk-mode-abbrev-table nil
  39.   "Abbrev table in use in smalltalk-mode buffers.")
  40. (define-abbrev-table 'smalltalk-mode-abbrev-table ())
  41.  
  42. ;;; this hack was to play around with adding Smalltalk-specific menu items
  43. ;;; to the Emacstool on the Sun.
  44. (if (featurep 'sun-mouse)
  45.     (let (new-menu i)
  46.       (defmenu smalltalk-menu
  47.     ("Smalltalk")
  48.     ("Do it"))
  49.       (setq new-menu (make-vector (1+ (length emacs-menu)) nil))
  50.       (aset new-menu 0 (aref emacs-menu 0))
  51.       (setq i 1)
  52.       (while (< i (length emacs-menu))
  53.     (aset new-menu (1+ i) (aref emacs-menu i))
  54.     (setq i (1+ i)))
  55.       (aset new-menu 1 '("Smalltalk" . smalltalk-menu))
  56.       (setq emacs-menu new-menu)
  57.       )
  58.   )
  59.  
  60. (defvar smalltalk-mode-map nil "Keymap used in Smalltalk mode.")
  61. (if smalltalk-mode-map
  62.     ()
  63.   (setq smalltalk-mode-map (make-sparse-keymap))
  64.   (define-key smalltalk-mode-map "\t" 'smalltalk-tab)
  65.   (define-key smalltalk-mode-map "\177" 'backward-delete-char-untabify)
  66.   (define-key smalltalk-mode-map "\n" 'smalltalk-newline-and-indent)
  67.   (define-key smalltalk-mode-map "\C-\M-a" 'smalltalk-begin-of-defun)
  68.   (define-key smalltalk-mode-map "\C-\M-f" 'smalltalk-forward-sexp)
  69.   (define-key smalltalk-mode-map "\C-\M-b" 'smalltalk-backward-sexp)
  70.   (define-key smalltalk-mode-map "!"     'smalltalk-bang)
  71.   (define-key smalltalk-mode-map ":"    'smalltalk-colon)
  72.   (define-key smalltalk-mode-map "\M-\t"    'smalltalk-reindent)
  73. ;; just examples
  74. ;;  (define-key c-mode-map "{" 'electric-c-brace)
  75. ;;  (define-key c-mode-map "\e\C-h" 'mark-c-function)
  76. ;;  (define-key c-mode-map "\e\C-q" 'indent-c-exp)
  77.   )
  78.  
  79. (defvar smalltalk-mode-syntax-table nil
  80.   "Syntax table in use in smalltalk-mode buffers.")
  81.  
  82. (if smalltalk-mode-syntax-table
  83.     ()
  84.   (setq smalltalk-mode-syntax-table (make-syntax-table))
  85.   (modify-syntax-entry ?\' "\"" smalltalk-mode-syntax-table)
  86.   ;; GNU Emacs is deficient: there seems to be no way to have a comment char
  87.   ;; that is both the start and end character.  This is going to cause
  88.   ;; me great pain.
  89.   (modify-syntax-entry ?\" "\"" smalltalk-mode-syntax-table)
  90.   (modify-syntax-entry ?+ "." smalltalk-mode-syntax-table)
  91.   (modify-syntax-entry ?- "." smalltalk-mode-syntax-table)
  92.   (modify-syntax-entry ?* "." smalltalk-mode-syntax-table)
  93.   (modify-syntax-entry ?/ "." smalltalk-mode-syntax-table)
  94.   (modify-syntax-entry ?= "." smalltalk-mode-syntax-table)
  95.   (modify-syntax-entry ?% "." smalltalk-mode-syntax-table)
  96.   (modify-syntax-entry ?< "." smalltalk-mode-syntax-table)
  97.   (modify-syntax-entry ?> "." smalltalk-mode-syntax-table)
  98.   (modify-syntax-entry ?& "." smalltalk-mode-syntax-table)
  99.   (modify-syntax-entry ?$ "\\" smalltalk-mode-syntax-table)
  100.   (modify-syntax-entry ?# "'" smalltalk-mode-syntax-table)
  101.   (modify-syntax-entry ?| "." smalltalk-mode-syntax-table)
  102.   (modify-syntax-entry ?_ "." smalltalk-mode-syntax-table)
  103.   (modify-syntax-entry ?\\ "." smalltalk-mode-syntax-table)
  104.   (modify-syntax-entry ?! "." smalltalk-mode-syntax-table)
  105.   )
  106.  
  107. (defconst smalltalk-indent-amount 4
  108.   "*'Tab size'; used for simple indentation alignment.")
  109.  
  110. (autoload 'smalltalk-install-change-log-functions "st-changelog")
  111.  
  112. (defun stm ()
  113.   (smalltalk-mode))
  114.  
  115. (defun smalltalk-mode ()
  116.   "Major mode for editing Smalltalk code.
  117. Comments are delimited with \" ... \".
  118. Paragraphs are separated by blank lines only.
  119. Delete converts tabs to spaces as it moves back.
  120.  
  121. Of special interest are the commands for interacting with a live Smalltalk 
  122. session: 
  123. \\[mst]
  124.     Invoke the Smalltalk interactor, which basically keeps the current buffer
  125.     in one window, and creates another window with a running Smalltalk in it.
  126.     The other window behaves essentially like a shell-mode window when the
  127.     cursor is in it, but it will receive the operations requested when the
  128.     interactor related commands are used.
  129.  
  130. \\[smalltalk-doit]
  131.     interactively evaluate the expression that the cursor is in in a Smalltalk
  132.     mode window, or with an argument execute the region as smalltalk code
  133.  
  134. \\[smalltalk-compile]
  135.     compile the method definition that the cursor is currently in.
  136.  
  137. \\[smalltalk-snapshot]
  138.     produce a snapshot binary image of the current working Smalltalk system.
  139.     Useful to do periodically as you define new methods to save the state of
  140.     your work.
  141.  
  142. \\{smalltalk-mode-map}
  143.  
  144. Turning on Smalltalk mode calls the value of the variable
  145. smalltalk-mode-hook with no args, if that value is non-nil."
  146.   (interactive)
  147.   (kill-all-local-variables)
  148.   (use-local-map smalltalk-mode-map)
  149.   (setq major-mode 'smalltalk-mode)
  150.   (setq mode-name "Smalltalk")
  151.   (setq local-abbrev-table smalltalk-mode-abbrev-table)
  152.   (set-syntax-table smalltalk-mode-syntax-table)
  153.   (make-local-variable 'paragraph-start)
  154.   (setq paragraph-start (concat "^$\\|" page-delimiter))
  155.   (make-local-variable 'paragraph-separate)
  156.   (setq paragraph-separate paragraph-start)
  157.   (make-local-variable 'paragraph-ignore-fill-prefix)
  158.   (setq paragraph-ignore-fill-prefix t)
  159.   (make-local-variable 'indent-line-function)
  160.   (setq indent-line-function 'smalltalk-indent-line)
  161.   (make-local-variable 'require-final-newline)
  162.   (setq require-final-newline t)
  163.   (make-local-variable 'comment-start)
  164.   (setq comment-start "\"")
  165.   (make-local-variable 'comment-end)
  166.   (setq comment-end "\"")
  167.   (make-local-variable 'comment-column)
  168.   (setq comment-column 32)
  169.   (make-local-variable 'comment-start-skip)
  170.   (setq comment-start-skip "\" *")
  171.   (make-local-variable 'comment-indent-hook)
  172.   (setq comment-indent-hook 'smalltalk-comment-indent)
  173.   (make-local-variable 'parse-sexp-ignore-comments)
  174.   (setq parse-sexp-ignore-comments nil)    ;for interactive f-b sexp
  175.   (smalltalk-install-change-log-functions)
  176.   (run-hooks 'smalltalk-mode-hook))
  177.  
  178. ;; This is used by indent-for-comment
  179. ;; to decide how much to indent a comment in Smalltalk code
  180. ;; based on its context.
  181. (defun smalltalk-comment-indent ()
  182.   (if (looking-at "^\"")
  183.       0                ;Existing comment at bol stays there.
  184.     (save-excursion
  185.       (skip-chars-backward " \t")
  186.       (max (1+ (current-column))    ;Else indent at comment column
  187.        comment-column))))    ; except leave at least one space.
  188.  
  189. (defun smalltalk-indent-line ()
  190.   (indent-relative-maybe)
  191.   )
  192.  
  193. (defun smalltalk-previous-nonblank-line ()
  194.   (forward-line -1)
  195.   (while (and (not (bobp))
  196.           (looking-at "^[ \t]*$"))
  197.     (forward-line -1))
  198.   )
  199.  
  200. (defun smalltalk-tab ()
  201.   (interactive)
  202.   (let (col)
  203.     ;; round up, with overflow
  204.     (setq col (* (/ (+ (current-column) smalltalk-indent-amount)
  205.             smalltalk-indent-amount)
  206.          smalltalk-indent-amount))
  207.   (indent-to-column col)
  208.   ))
  209.  
  210. (defun smalltalk-begin-of-defun ()
  211.   (interactive)
  212.   (let ((parse-sexp-ignore-comments t) here)
  213.     ;; this routine is fooled by !s in character strings.
  214.     (setq here (point))
  215.     (if (search-backward "!" nil 'to-end)
  216.     (forward-char 1))
  217.     (smalltalk-forward-whitespace)
  218.     ;; yeah, yeah, it's crude, but it gets the job done.
  219.     (if (= here (point))        ;do it again
  220.     (progn
  221.       (if (search-backward "!" nil 'to-end 2)
  222.           (forward-char 1))
  223.       (smalltalk-forward-sexp 1)
  224.       (backward-sexp 1)))
  225.   ))
  226.  
  227. (defun smalltalk-forward-whitespace ()
  228.   "Skip white space and comments forward, stopping at end of buffer
  229. or non-white space, non-comment character"
  230.   (while (looking-at (concat "[" smalltalk-whitespace "\"]"))
  231.     (skip-chars-forward smalltalk-whitespace)
  232.     (if (= (following-char) ?\")
  233.     (forward-sexp 1)))
  234.   )
  235.  
  236. (defun smalltalk-backward-whitespace ()
  237.   "Like forward whitespace only going towards the start of the buffer"
  238.   (while (progn (skip-chars-backward smalltalk-whitespace)
  239.         (= (preceding-char) ?\"))
  240.     (backward-sexp 1))
  241.   )
  242.  
  243. (defun smalltalk-forward-sexp (n)
  244.   (interactive "p")
  245.   (let (i)
  246.     (cond ((null parse-sexp-ignore-comments)
  247.        (forward-sexp n))
  248.       ((< n 0)
  249.        (smalltalk-backward-sexp (- n)))
  250.       (t
  251.        (while (> n 0)
  252.          (smalltalk-forward-whitespace)
  253.          (forward-sexp 1)
  254.          (setq n (1- n))
  255.          )
  256.        )
  257.       )
  258.     )
  259.   )
  260.  
  261. (defun smalltalk-backward-sexp (n)
  262.   (interactive "p")
  263.   (let (i)
  264.     (cond ((null parse-sexp-ignore-comments)
  265.        (backward-sexp n))
  266.       ((< n 0)
  267.        (smalltalk-forward-sexp (- n)))
  268.       (t
  269.        (while (> n 0)
  270.          (smalltalk-backward-whitespace)
  271.          (backward-sexp 1)
  272.          (setq n (1- n))
  273.          )
  274.       )))
  275.   )
  276.  
  277. (defun smalltalk-reindent ()
  278.   (interactive)
  279.   (beginning-of-line)
  280.   (delete-horizontal-space)
  281.   (delete-char -1)
  282.   (smalltalk-newline-and-indent 1))
  283.  
  284. (defun smalltalk-newline-and-indent (levels)
  285.   "Called basically to do newline and indent.  Sees if the current line is a 
  286. new statement, in which case the indentation is the same as the previous 
  287. statement (if there is one), or is determined by context; or, if the current 
  288. line is not the start of a new statement, in which case the start of the 
  289. previous line is used, except if that is the start of a new line in which case
  290. it indents by smalltalk-indent-amount."
  291.   (interactive "p")
  292.   (let (needs-indent indent-amount done c state start-of-line
  293.              (parse-sexp-ignore-comments t))
  294.     (save-excursion
  295.       (save-restriction
  296.     (save-excursion
  297.       (smalltalk-backward-whitespace)
  298.       (if (or (bobp)
  299.           (= (preceding-char) ?!))
  300.           (setq indent-amount 0))
  301.       )
  302.     (if (null indent-amount)
  303.         (progn
  304.           (smalltalk-narrow-to-method)
  305.           (setq state (parse-partial-sexp (point-min) (point)))
  306.           (if (nth 3 state)        ;in a string or comment
  307.           (cond ((= (nth 3 state) ?\") ;in a comment
  308.              (save-excursion
  309.                (smalltalk-backward-comment)
  310.                (setq indent-amount (1+ (current-column)))
  311.                ))
  312.             ((= (nth 3 state) ?')    ;in a string
  313.              (setq indent-amount 0))
  314.             )
  315.         (narrow-to-paren state)
  316.         (smalltalk-backward-whitespace)
  317.         (cond ((bobp)            ;must be first statment in block or exp
  318.                (if (nth 1 state)    ;we're in a paren exp
  319.                (setq indent-amount (current-column))
  320.              ;; we're top level
  321.              (setq indent-amount smalltalk-indent-amount)))
  322.               ((= (preceding-char) ?.) ;at end of statement
  323.                (smalltalk-find-statement-begin)
  324.                (setq indent-amount (current-column)))
  325.               ((= (preceding-char) ?:)
  326.                (beginning-of-line)
  327.                (smalltalk-forward-whitespace)
  328.                (setq indent-amount (+ (current-column)
  329.                           smalltalk-indent-amount))
  330.                )
  331.               ((= (preceding-char) ?>) ;maybe <primitive: xxx>
  332.                (setq orig (point))
  333.                (backward-char 1)
  334.                (smalltalk-backward-whitespace)
  335.                (skip-chars-backward "0-9")
  336.                (smalltalk-backward-whitespace)
  337.                (if (= (preceding-char) ?:)
  338.                (progn
  339.                  (backward-char 1)
  340.                  (skip-chars-backward "a-zA-Z")
  341.                  (if (looking-at "primitive:")
  342.                  (progn
  343.                    (smalltalk-backward-whitespace)
  344.                    (if (= (preceding-char) ?<)
  345.                        (setq indent-amount (1- (current-column))))
  346.                    )
  347.                    )
  348.                  )
  349.              )
  350.                (if (null indent-amount)
  351.                (progn
  352.                  (goto-char orig)
  353.                  (smalltalk-find-statement-begin)
  354.                  (setq indent-amount (+ (current-column)
  355.                             smalltalk-indent-amount))
  356.                  )
  357.              )
  358.                )
  359.               (t            ;must be a statement continuation
  360.                (save-excursion
  361.              (beginning-of-line)
  362.              (setq start-of-line (point)))
  363.                (smalltalk-find-statement-begin)
  364.                (setq indent-amount (+ (current-column)
  365.                           smalltalk-indent-amount))
  366.                )
  367.               )
  368.         )
  369.           ))
  370.     )
  371.       )
  372.     (newline)
  373.     (delete-horizontal-space)        ;remove any carried-along whites
  374.     (indent-to indent-amount)
  375.     ))
  376.  
  377. (defun smalltalk-find-statement-begin ()
  378.   "Leaves the point at the first non-blank, non-comment character of a new
  379. statement.  If begininning of buffer is reached, then the point is left there.
  380. This routine only will return with the point pointing at the first non-blank
  381. on a line; it won't be fooled by multiple statements on a line into stopping
  382. prematurely."
  383.   (let (start)
  384.     (if (= (preceding-char) ?.)        ;if we start at eos
  385.     (backward-char 1))        ;we find the begin of THAT stmt
  386.     (while (and (null start) (not (bobp)))
  387.       (smalltalk-backward-whitespace)
  388.       (if (= (preceding-char) ?.)
  389.       (let (saved-point)
  390.         (setq saved-point (point))
  391.         (smalltalk-forward-whitespace)
  392.         (if (smalltalk-white-to-bolp)
  393.         (setq start (point))
  394.           (goto-char saved-point)
  395.           (smalltalk-backward-sexp 1))
  396.         )
  397.     (smalltalk-backward-sexp 1)
  398.     )
  399.       )
  400.     (if (null start)
  401.       (progn
  402.     (goto-char (point-min))
  403.     (smalltalk-forward-whitespace)
  404.     (setq start (point))))
  405.   start))
  406.     
  407.  
  408. ;;; hold on to this code for a little bit, but then flush it
  409. ;;;      
  410. ;;;      ;; not in a comment, so skip backwards for some indication
  411. ;;;      (smalltalk-backward-whitespace)
  412. ;;;      (if (bobp)
  413. ;;;          (setq indent-amount smalltalk-indent-amount)
  414. ;;;        (setq c (preceding-char))
  415. ;;;        (cond ((eq c ?.)        ;this is a new statement
  416. ;;;           (smalltalk-backward-statement)
  417. ;;;           (setq indent-amount (current-column)))
  418. ;;;          ((memq c '(?|
  419. ;;;                 
  420. ;;;                 (smalltalk-narrow-to-method)
  421. ;;;                 
  422. ;;;                 (smalltalk-backward-whitespace)
  423. ;;;                 (setq c (preceding-char))
  424. ;;;                 (cond
  425. ;;;                  ((memq c '(?. ?| ?\[ ?\( )) (setq done t))
  426. ;;;                  ((eq c ?:)
  427. ;;;                   (backward-char 1)
  428. ;;;                   (skip-chars-backward "a-zA-Z0-9")
  429. ;;;                   (setq indent-amount (current-column)))
  430. ;;;                  (t
  431. ;;;                   (smalltalk-backward-sexp 1)))
  432. ;;;                 )
  433. ;;;             
  434. ;;;             )
  435. ;;;           )
  436. ;;;          (if indent-amount
  437. ;;;              (save-excursion
  438. ;;;            (beginning-of-line)
  439. ;;;            (delete-horizontal-space)
  440. ;;;            (indent-to indent-amount))
  441. ;;;            )
  442. ;;;          (insert last-command-char)
  443. ;;;          ))
  444.       
  445. (defun narrow-to-paren (state)
  446.   (let ((paren-addr (nth 1 state))
  447.     start c done)
  448.     (if (not paren-addr) nil
  449.       (save-excursion
  450.     (goto-char paren-addr)
  451.     (setq c (following-char))
  452.     (cond ((eq c ?\()
  453.            (setq start (1+ (point))))
  454.           ((eq c ?\[)
  455.            (setq done nil)
  456.            (forward-char 1)
  457.            (while (not done)
  458.          (smalltalk-forward-whitespace)
  459.          (setq c (following-char))
  460.          (cond ((eq c ?:)
  461.             (smalltalk-forward-sexp 1))
  462.                ((eq c ?|)
  463.             (forward-char 1) ;skip vbar
  464.             (smalltalk-forward-whitespace) ;move to non-blank
  465.             (setq done t))    ;and leave
  466.                (t
  467.             (setq done t))
  468.                )
  469.          )
  470.            (setq start (point))
  471.            )
  472.           )
  473.     )
  474.       (narrow-to-region start (point))
  475.       )
  476.     )
  477.   )
  478.  
  479.  
  480.  
  481. (defun smalltalk-colon ()
  482.   "Possibly reindents a line when a colon is typed.
  483. If the colon appears on a keyword that's at the start of the line (ignoring
  484. whitespace, of course), then the previous line is examined to see if there
  485. is a colon on that line, in which case this colon should be aligned with the 
  486. left most character of that keyword.  This function is not fooled by nested 
  487. expressions."
  488.   (interactive)
  489.   (let (needs-indent indent-amount done c
  490.              (parse-sexp-ignore-comments t))
  491.     (save-excursion
  492.       (skip-chars-backward "A-Za-z0-9")
  493.       (if (and (looking-at smalltalk-name-regexp) (not (bolp)))
  494.       (setq needs-indent (smalltalk-white-to-bolp))
  495.     )
  496.       )
  497.     (if needs-indent
  498.     (progn 
  499.       (save-excursion
  500.         (save-restriction
  501.           (smalltalk-narrow-to-method)
  502.           (beginning-of-line)
  503.           (while (and (not done)
  504.               (not (bobp)))
  505.         (smalltalk-backward-whitespace)
  506.         (setq c (preceding-char))
  507.         (cond
  508.          ((memq c '(?. ?| ?\[ ?\( ?^)) (setq done t))
  509.          ((eq c ?:)
  510.           (backward-char 1)
  511.           (skip-chars-backward "a-zA-Z0-9")
  512.           (setq indent-amount (current-column)))
  513.          (t
  514.           (smalltalk-backward-sexp 1)))
  515.         )
  516.           
  517.           )
  518.         )
  519.       (if indent-amount
  520.           (save-excursion
  521.         (beginning-of-line)
  522.         (delete-horizontal-space)
  523.         (indent-to indent-amount))
  524.         )
  525.       )
  526.       )
  527.     (expand-abbrev)            ;I don't think this is the "correct"
  528.                     ;way to do this...I suspect that
  529.                     ;some flavor of "call interactively"
  530.                     ;is better.
  531.     (insert last-command-char)
  532.     ))
  533.  
  534. (defun smalltalk-narrow-to-method ()
  535.   "Narrows the buffer to the contents of the method, exclusive of the
  536. method selector and temporaries."
  537.   (let ((end (point))
  538.     (parse-sexp-ignore-comments t)
  539.     done)
  540.     (save-excursion
  541.       (smalltalk-begin-of-defun)
  542.       (if (looking-at "[a-zA-z]")        ;either unary or keyword msg
  543.       ;; or maybe an immediate expression...
  544.       (progn
  545.         (forward-sexp)
  546.         (if (= (following-char) ?:)    ;keyword selector
  547.         (progn
  548.           (backward-sexp 1)    ;setup for common code
  549.           (while (not done)
  550.             (if (not (looking-at "[a-zA-Z]"))
  551.             (setq done t)
  552.               (skip-chars-forward smalltalk-name-chars)
  553.               (if (= (following-char) ?:)
  554.               (progn
  555.                 (forward-char)
  556.                 (smalltalk-forward-sexp 1)
  557.                 (smalltalk-forward-whitespace))
  558.             (setq done t)
  559.             (backward-sexp 1))
  560.               )
  561.             )
  562.           )
  563.           ;; else maybe just a unary selector or maybe not
  564.           ;; see if there's stuff following this guy on the same line
  565.           (let (here eol-point)
  566.         (setq here (point))
  567.         (end-of-line)
  568.         (setq eol-point (point))
  569.         (goto-char here)
  570.         (smalltalk-forward-whitespace)
  571.         (if (< (point) eol-point) ;if there is, we're not a method
  572.                     ; (a heuristic guess)
  573.             (beginning-of-line)
  574.           (goto-char here)    ;else we're a unary method (guess)
  575.           )
  576.         )
  577.           )
  578.         )
  579.     
  580.     ;; this must be a binary selector
  581.     (skip-chars-forward (concat "^" smalltalk-whitespace))
  582.     (smalltalk-forward-whitespace)
  583.     (skip-chars-forward smalltalk-name-chars)) ;skip over operand
  584.       (skip-chars-forward smalltalk-whitespace)
  585.       (if (= (following-char) ?|)    ;scan for temporaries
  586.       (progn
  587.         (forward-char)
  588.         (while (/= (following-char) ?|)
  589.           (smalltalk-forward-whitespace)
  590.           (skip-chars-forward smalltalk-name-chars)
  591.           )
  592.         (forward-char)        ;skip over trailing |
  593.         )
  594.     )
  595.       (narrow-to-region (point) end)
  596.       )
  597.     )
  598.   )
  599.  
  600. (defun smalltalk-white-to-bolp ()
  601.   "Returns T if from the current position to beginning of line is whitespace.
  602. Whitespace is defined as spaces, tabs, and comments."
  603.   (let (done is-white line-start-pos)
  604.     (save-excursion
  605.       (save-excursion
  606.     (beginning-of-line)
  607.     (setq line-start-pos (point)))
  608.       (while (not done)
  609.     (skip-chars-backward " \t")
  610.     (cond ((bolp)
  611.            (setq done t)
  612.            (setq is-white t))
  613.           ((= (char-after (1- (point))) ?\")
  614.            (backward-sexp)
  615.            (if (< (point) line-start-pos) ;comment is multi line
  616.            (setq done t)
  617.            )
  618.            )
  619.           (t
  620.            (setq done t))
  621.           )
  622.     )
  623.       is-white)
  624.     ))
  625.  
  626.  
  627. (defun smalltalk-bang ()
  628.   (interactive)
  629.   (insert "!")
  630.   (save-excursion
  631.     (beginning-of-line)
  632.     (if (looking-at "^[ \t]+!")
  633.     (delete-horizontal-space))
  634.     )
  635.   )
  636.  
  637.  
  638. (defun smalltalk-backward-comment ()
  639.   (search-backward "\"")    ;find its start
  640.   (while (= (preceding-char) ?\") ;skip over doubled ones
  641.     (backward-char 1)
  642.     (search-backward "\""))
  643.   )
  644.  
  645.  
  646. (defun st-test ()            ;just an experimental testing harness
  647.   (interactive)
  648.   (let (l end)
  649.     (setq end (point))
  650.     (beginning-of-defun)
  651.     (setq l (parse-partial-sexp (point) end nil nil nil))
  652.     (message "%s" (prin1-to-string l)) (read-char)
  653.     (message "depth %s" (nth 1 l)) (goto-char (nth 1 l)) (read-char)
  654.     (message "last sexp %s" (nth 2 l)) (goto-char (nth 2 l)) (read-char)
  655.     (message "lstsx %s stp %s com %s quo %s pdep %s"
  656.        (nth 3 l)
  657.        (nth 4 l)
  658.        (nth 5 l)
  659.        (nth 6 l)
  660.        (nth 7 l))
  661.     ))
  662.  
  663.  
  664. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  665. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  666. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  667. ;;;
  668. ;;; GNU Emacs Smalltalk interactor mode
  669. ;;; (initial cut)
  670. ;;;
  671. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  672. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  673. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  674.  
  675. (defvar *smalltalk-process* nil)
  676. (defvar mst-args "-Vp")
  677.  
  678. (define-key smalltalk-mode-map "\C-cc"     'smalltalk-compile)
  679. (define-key smalltalk-mode-map "\C-cd"     'smalltalk-doit)
  680. (define-key smalltalk-mode-map "\C-ce"     'smalltalk-eval-region)
  681. (define-key smalltalk-mode-map "\C-cf"     'smalltalk-filein)
  682. (define-key smalltalk-mode-map "\C-cm"     'mst)
  683. (define-key smalltalk-mode-map "\C-cp"     'smalltalk-print)
  684. (define-key smalltalk-mode-map "\C-cq"     'smalltalk-quit)
  685. (define-key smalltalk-mode-map "\C-cs"     'smalltalk-snapshot)
  686.  
  687.  
  688.  
  689. (defun mst (args)
  690.   (interactive (list (if (null current-prefix-arg)
  691.              mst-args
  692.              (read-string "Invoke Smalltalk: " mst-args))))
  693.   (setq mst-args args)
  694.   (switch-to-buffer-other-window
  695.    (make-mst "mst" mst-args))
  696.   (setq *smalltalk-process* (get-buffer-process (current-buffer)))
  697.   )
  698.  
  699. (defun make-mst (name &rest switches)
  700.   (let ((buffer (get-buffer-create (concat "*" name "*")))
  701.     proc status size)
  702.     (setq proc (get-buffer-process buffer))
  703.     (if proc (setq status (process-status proc)))
  704.     (save-excursion
  705.       (set-buffer buffer)
  706.       ;;    (setq size (buffer-size))
  707.       (if (memq status '(run stop))
  708.       nil
  709.     (if proc (delete-process proc))
  710.     (setq proc (apply 'start-process name buffer
  711.               (concat exec-directory "env")
  712.               ;; I'm choosing to leave these here
  713.               (format "TERMCAP=emacs:co#%d:tc=unknown:"
  714.                   (screen-width))
  715.               "TERM=emacs"
  716.               "EMACS=t"
  717.               "-"
  718.               "mst"
  719.               switches))
  720.     (setq name (process-name proc)))
  721.       (goto-char (point-max))
  722.       (set-marker (process-mark proc) (point))
  723.       (set-process-filter proc 'mst-filter)
  724.       (mst-mode))
  725.     buffer))
  726.  
  727. (defun mst-filter (process string)
  728.   "Make sure that the window continues to show the most recently output 
  729. text."
  730.   (let (where)
  731.   (save-excursion
  732.     (set-buffer (process-buffer process))
  733.     (goto-char (point-max))
  734.     (while (setq where (string-match "\C-a" string))
  735.       (setq string (concat (substring string 0 where)
  736.                (substring string (1+ where))))
  737.       (setq mode-status "idle"))
  738.     (insert string)
  739.     (if (process-mark process)
  740.     (set-marker (process-mark process) (point-max)))
  741.     )
  742. ;;  (if (eq (process-buffer process)
  743. ;;      (current-buffer))
  744. ;;      (goto-char (point-max)))
  745. ;  (save-excursion
  746. ;      (set-buffer (process-buffer process))
  747. ;      (goto-char (point-max))
  748. ;;      (set-window-dot (get-buffer-window (current-buffer)) (point-max))
  749. ;      (sit-for 0))
  750.   (let ((buf (current-buffer)))
  751.     (set-buffer (process-buffer process))
  752.     (goto-char (point-max)) (sit-for 0)
  753.     (set-window-dot (get-buffer-window (current-buffer)) (point-max))
  754.     (set-buffer buf))
  755.   ))
  756.  
  757.  
  758. (defun mst-mode ()
  759.   "Major mode for interacting Smalltalk subprocesses.
  760.  
  761. The following commands imitate the usual Unix interrupt and
  762. editing control characters:
  763. \\{shell-mode-map}
  764.  
  765. Entry to this mode calls the value of mst-mode-hook with no arguments,
  766. if that value is non-nil.  Likewise with the value of shell-mode-hook.
  767. mst-mode-hook is called after shell-mode-hook."
  768.   (interactive)
  769.   (kill-all-local-variables)
  770.   (setq mode-line-format
  771.     '("" mode-line-modified mode-line-buffer-identification "   "
  772.       global-mode-string "   %[(" mode-name ": " mode-status
  773.       "%n" mode-line-process ")%]----" (-3 . "%p") "-%-"))
  774.   (setq major-mode 'mst-mode)
  775.   (setq mode-name "Smalltalk")
  776. ;;  (setq mode-line-process '(": %s"))
  777.   (use-local-map shell-mode-map)
  778.   (make-local-variable 'last-input-start)
  779.   (setq last-input-start (make-marker))
  780.   (make-local-variable 'last-input-end)
  781.   (setq last-input-end (make-marker))
  782.   (make-local-variable 'mode-status)
  783.   (setq mode-status "starting-up")
  784.   (run-hooks 'shell-mode-hook 'mst-mode-hook))
  785.  
  786.  
  787.  
  788. (defun smalltalk-eval-region (start end &optional label)
  789.   "Evaluate START to END as a Smalltalk expression in Smalltalk window.
  790. If the expression does not end with an exclamation point, one will be
  791. added (at no charge)."
  792.   (interactive "r")
  793.   (let (str)
  794.     (setq str (buffer-substring start end))
  795.     (save-excursion
  796.       (goto-char (max start end))
  797.       (smalltalk-backward-whitespace)
  798.       (if (/= (preceding-char) ?!)    ;canonicalize
  799.       (setq str (concat str "!")))
  800.       )
  801.     (send-to-smalltalk str (or label "eval"))
  802.     )
  803.   )
  804.  
  805.  
  806. (defun smalltalk-doit (use-region)
  807.   (interactive "P")
  808.   (let (start end rgn)
  809.     (if use-region
  810.     (progn
  811.       (setq start (min (mark) (point)))
  812.       (setq end (max (mark) (point)))
  813.       )
  814.       (setq rgn (smalltalk-bound-expr))
  815.       (setq start (car rgn)
  816.         end (cdr rgn))
  817.       )
  818.     (smalltalk-eval-region start end "doIt")
  819.     )
  820.   )
  821.  
  822. (defun smalltalk-bound-expr ()
  823.   "Returns a cons of the region of the buffer that contains a smalltalk expression.
  824. It's pretty dumb right now...looks for a line that starts with ! at the end and
  825. a non-white-space line at the beginning, but this should handle the typical
  826. cases nicely."
  827.   (let (start end here)
  828.     (save-excursion
  829.       (setq here (point))
  830.       (re-search-forward "^!")
  831.       (setq end (point))
  832.       (beginning-of-line)
  833.       (if (looking-at "^[^ \t\"]")
  834.       (progn
  835.         (goto-char here)
  836.         (re-search-backward "^[^ \t\"]")
  837.         (while (looking-at "^$")        ;this is a hack to get around a bug
  838.           (re-search-backward "^[^ \t\"]");with GNU Emacs's regexp system
  839.           )
  840.         )
  841.     )
  842.       (setq start (point))
  843.       (cons start end)
  844.       )
  845.     )
  846.   )
  847.  
  848. (defun smalltalk-compile (use-region)
  849.   (interactive "P")
  850.   (let (str start end rgn)
  851.     (if use-region
  852.     (progn
  853.       (setq start (min (point) (mark)))
  854.       (setq end (max (point) (mark)))
  855.       (setq str (buffer-substring start end))
  856.       (save-excursion
  857.         (goto-char end)
  858.         (smalltalk-backward-whitespace)
  859.         (if (/= (preceding-char) ?!)    ;canonicalize
  860.         (setq str (concat str "!")))
  861.         )
  862.       (send-to-smalltalk str "compile"))
  863.       (setq rgn (smalltalk-bound-method))
  864.       (setq str (buffer-substring (car rgn) (cdr rgn)))
  865.       (save-excursion
  866.     (re-search-backward "^![ \t]*[A-Za-z]")
  867.     (setq start (point))
  868.     (forward-char 1)
  869.     (search-forward "!")
  870.     (setq end (point)))
  871.       (setq str (concat (buffer-substring start end) "\n\n" str "!"))
  872.       (send-to-smalltalk str "compile")
  873.     )
  874.   )
  875.   )
  876.  
  877.  
  878. (defun smalltalk-bound-method ()
  879.   (let (start end)
  880.     (save-excursion
  881.       (re-search-forward "^!")
  882.       (setq end (point)))
  883.     (save-excursion
  884.       (re-search-backward "^[^ \t\"]")
  885.       (while (looking-at "^$")        ;this is a hack to get around a bug
  886.     (re-search-backward "^[^ \t\"]");with GNU Emacs's regexp system
  887.     )
  888.       (setq start (point)))
  889.     (cons start end))
  890.   )
  891.  
  892.  
  893. (defun smalltalk-snapshot (&optional snapshot-name)
  894.   (interactive (if current-prefix-arg
  895.            (list (setq snapshot-name (expand-file-name (read-file-name "Snapshot to: "))))))
  896.   (if snapshot-name
  897.       (send-to-smalltalk (format "Smalltalk snapshot: '%s'!" "Snapshot"))
  898.   (send-to-smalltalk "Smalltalk snapshot!" "Snapshot"))
  899.   )
  900.  
  901. (defun smalltalk-print (start end)
  902.   (interactive "r")
  903.   (let (str)
  904.     (setq str (buffer-substring start end))
  905.     (save-excursion
  906.       (goto-char (max start end))
  907.       (smalltalk-backward-whitespace)
  908.       (if (= (preceding-char) ?!)    ;canonicalize
  909.       (setq str (buffer-substring (min start end)  (point)))
  910.     )
  911.       (setq str (format "(%s) printNl!" str))
  912.       (send-to-smalltalk str "print")
  913.       )
  914.     )
  915.   )
  916.  
  917.  
  918. (defun smalltalk-quit ()
  919.   (interactive)
  920.   (send-to-smalltalk "Smalltalk quitPrimitive!" "Quitting"))
  921.  
  922. (defun smalltalk-filein (filename)
  923.   (interactive "fSmalltalk file to load: ")
  924.   (send-to-smalltalk (format "FileStream fileIn: '%s'!"
  925.                  (expand-file-name filename))
  926.              "fileIn")
  927.   )
  928.  
  929. (defun send-to-smalltalk (str &optional mode)
  930.   (let (temp-file buf)
  931.     (setq temp-file (concat "/tmp/" (make-temp-name "mst")))
  932.     (save-excursion
  933.       (setq buf (get-buffer-create " zap-buffer "))
  934.       (set-buffer buf)
  935.       (erase-buffer)
  936.       (princ str (current-buffer))
  937.       (write-region (point-min) (point-max) temp-file nil 'no-message)
  938.       )
  939.     (kill-buffer buf)
  940.     (if mode
  941.     (progn
  942.       (save-excursion
  943.         (set-buffer (process-buffer *smalltalk-process*))
  944.         (setq mode-status mode))
  945.       ))
  946.     (switch-to-buffer-other-window (process-buffer *smalltalk-process*))
  947.     (goto-char (point-max))
  948.     (newline)
  949.     (other-window 1)
  950.       ;;(sit-for 0)
  951.     (process-send-string *smalltalk-process*
  952.              (concat "FileStream fileIn: '" temp-file "'!\n"))
  953.     )
  954.   )
  955.  
  956.  
  957.  
  958. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  959. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  960. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  961. ;;;
  962. ;;; GNU Emacs hooks for invoking Emacs on Smalltalk methods
  963. ;;; 
  964. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  965. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  966. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  967.  
  968.  
  969.  
  970. (setq command-switch-alist
  971.       (append '(("-smalltalk" . smalltalk-edit))
  972.           command-switch-alist))
  973.  
  974.  
  975. (defun smalltalk-edit (rest)
  976.   (let (file pos done)
  977.     (setq file (car command-line-args-left))
  978.     (setq command-line-args-left
  979.       (cdr command-line-args-left))
  980.     (setq pos (string-to-int (car command-line-args-left)))
  981.     (setq command-line-args-left
  982.       (cdr command-line-args-left))
  983.     (find-file (expand-file-name file))
  984.     (goto-char pos)
  985.     )
  986.   )
  987.